home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / Module source / xlatnu < prev   
Encoding:
Text File  |  1995-11-25  |  6.6 KB  |  258 lines  |  [TEXT/MACA]
  1. 6000 value maxTraps
  2.  
  3. string trapName
  4. string buf
  5. string temp
  6. string buildStr
  7. 0 value names
  8. sarray inLines
  9. \ new: Names
  10. new: inLines
  11. new: buildStr
  12.  
  13. new: trapName    100 setsize: trapName  lock: trapName
  14. new: buf
  15. new: temp
  16.  
  17. sarray debugStr
  18. new: debugStr
  19. true value debug?
  20. true value osErrs?
  21.  
  22. maxTraps heap> ordered-col -> names
  23.  
  24. \ parse the instructions after 'INLINE'. parse for ,  until reach a ;
  25. : inLineParse { addr0 \ addr char end -- addr addr' len }    \ addr left =0 if end
  26.     false -> end
  27.     addr0 -> addr
  28.     BEGIN addr c@ -> char
  29.         char ascii , =
  30.         char ascii ; = dup IF true -> end THEN or not
  31.     WHILE 1 ++> addr
  32.     REPEAT
  33.     end IF 0 ELSE addr 1+ THEN addr0 addr addr0 - ;
  34.  
  35. \ find Functions or Procedures
  36. : funprocParse { addr0 \ addr char len -- addr' len }    \ addr left =0 if end
  37.     addr0 -> addr
  38.     BEGIN addr c@ -> char
  39.         char ascii 0 >= 
  40.     WHILE 1 ++> addr
  41.     REPEAT
  42.     addr addr0 - -> len
  43.     addr0 len + 1- c@ ascii : =
  44.     IF -1 ++> len THEN
  45.     addr0 len ;
  46.  
  47. : readfile ( -- ) \ unlock: buf
  48.     new: loadfile TXTYPE 1 stdget: topfile
  49.     IF open: topfile abort" can't open"
  50.         topfile size: topfile read: buf drop
  51.     THEN remove: loadfile
  52.     start: buf ;
  53.  
  54. : (findThem) { addr len \ flag  -- b }    \ b=true ok, false nomore finds
  55.     0 -> flag
  56.     BEGIN
  57.         addr len indexof: buf
  58.         IF ptr: buf + dup 1- c@ 13 =
  59.             IF     bl parse 2drop funprocParse put: trapName uc: trapName 2drop
  60.                  true true -> flag 
  61.             ELSE drop 1 offset: buf false
  62.             THEN 
  63.         ELSE true false -> flag
  64.         THEN
  65.     UNTIL flag ; 
  66.  
  67. \ Find 'FUNCTION' or 'PROCEDURE' that begins a new line, then search for the
  68. \ word 'INLINE'. Then get the code string, parsing for commas and ending with semi
  69. \ colon.
  70.  
  71. : FindFunction " FUNCTION" (findThem) ;
  72. : FindProcedure " PROCEDURE" (findThem) ;
  73.  
  74. : findINLINE { \ addr where -- b } clear: buildStr
  75.     13 charof: buf drop  -> where 1 offset: buf 
  76.     13 charof: buf 2drop 1 offset: buf
  77.     ptr: buf where: buf + 13 parse put: temp drop
  78.     start: temp
  79.     " INLINE" indexof: temp
  80.         IF lock: temp ptr: temp + ascii $ parse 2drop -> addr
  81.             BEGIN  addr inLineParse add: buildStr -> addr
  82.                     lock: buildStr
  83.                     start: buildStr ascii $ charof: buildStr
  84.                     IF drop bl 1 substr: buildStr drop c! THEN
  85.                     unlock: buildStr bl +: buildStr
  86.                     addr 0=
  87.             UNTIL unlock: temp
  88.         oserrs? IF  size: buildStr 6 - 0 max moveto: buildStr
  89.                     " 3E80" indexOf: buildStr
  90.                     IF drop 4 substr: buildStr " 2F00" replace: buildStr THEN
  91.                 THEN
  92.             true
  93.         ELSE  print: trapName ."  INLINE not found" cr
  94.             where moveto: buf false
  95.         THEN ;
  96.  
  97. : endSpace ( addr -- addr) dup c@ bl = IF 1+ endSpace THEN ;
  98.  
  99. hex
  100. \ ( str255addr -- hashVal )  hash a  name into a 32-bit word
  101. create HashName 
  102.     2057    w,    \        move.l    (sp),a0
  103.     d1cb    w,    \        adda.l    a3,a0
  104.     7000    w,    \        moveq    #0,d0        \ Result will go to D0
  105.     7400    w,    \        moveq    #0,d2
  106.     1418    w,    \        move.b    (a0)+,d2    \ Count
  107.     c43c007f ,    \        and.b    #127,d2        \ Clear top bit in case it's a name field
  108.     60000008 ,    \        bra        lptest
  109.     ef98    w,    \ loop    rol.l    #7,d0
  110.     1218    w,    \        move.b    (a0)+,d1
  111.     b300    w,    \        eor.b    d1,d0        \ b300
  112.     51cafff8 ,    \ lptest dbra    d2,loop
  113.     08c0001f ,    \        bset    #31,d0
  114.     2e80    w,    \        move.l    d0,(sp)
  115. next,
  116. decimal
  117.  
  118. \ 0 value addr
  119. \ 0 value trap#
  120. \ 0 value nhash
  121. \ 0 value endAddr
  122.  
  123. : MakeTool { \ addr trap# nhash endAddr -- } 
  124.     get: trapName
  125.     str255 -base -> addr
  126.     addr HashName -> nhash
  127.     nhash indexOf: names        ( trap# hashval [idx] bool )
  128.     IF   print: trapName ." collision" . cr    exit    \ mark collision item
  129.     ELSE nhash add: names
  130.     THEN
  131.     lock: buildStr get: buildStr + 1- -> endAddr
  132.     ptr: buildStr -> Addr
  133.     clear: temp hex
  134.     BEGIN addr endAddr <
  135.     WHILE 0.. addr  endspace 1- (number) -> addr drop pad  w! pad 2 add: temp ?pause
  136.     REPEAT decimal
  137.     lock: temp get: temp add: inlines
  138.     debug? IF temp =: trapName 9 +: temp get: buildStr add: temp get: temp add: debugStr THEN
  139.     unlock: temp unlock: buildStr ;
  140.  
  141. : doit readfile size: buf
  142.     IF start: buf lock: buf
  143.         BEGIN findFunction
  144.         WHILE findInLine IF MakeTool THEN
  145.         REPEAT
  146.         start: buf
  147.         BEGIN findProcedure
  148.         WHILE findInLine IF MakeTool THEN
  149.         REPEAT
  150.     THEN
  151.     unlock: buf clear: buf  ;
  152.  
  153.  
  154. \ get info for default vol - leave vol name at pad
  155. : volinfo { -- fcode }
  156.     0 ffcb 22 + w!
  157.     0 ffcb 28 + w!
  158.     HFS? IF
  159.         9 ffcb +base dirfind
  160.     ELSE ffcb fcall pbgetvinfo
  161.     then ;
  162. \ ( -- #files )
  163. : filecount volinfo drop
  164.     HFS? IF ffcb 52 + w@
  165.     ELSE ffcb 40 + w@
  166.     THEN ;
  167.  
  168. \ ( file# -- b )  leave name of file at pad
  169. : Getidxfile { \ dirid -- }
  170.     fFcb 28 + w!            \ set file index
  171.     pad +base fFcb 18 + !    \ filename addr
  172.     pad 64 blanks getdirid: ffcb -> dirid
  173.     fFcb fcall PBHGetFInfo
  174.     0= IF true ELSE  false THEN
  175.     dirid setdirid: ffcb
  176.     13 pad count + 1+ c! ;
  177.  
  178.  
  179. : uhuh     ." reading: " print: topfile cr
  180.     topfile size: topfile read: buf drop
  181.     size: buf
  182.     IF start: buf lock: buf
  183.         BEGIN findFunction
  184.         WHILE findInLine IF  MakeTool THEN
  185.         REPEAT
  186.         start: buf
  187.         BEGIN findProcedure
  188.         WHILE findInLine IF MakeTool THEN
  189.         REPEAT
  190.     THEN
  191.     unlock: buf clear: buf ;
  192.  
  193. \ This is the word to execute, making sure the pathList is setup using the 'cl'
  194. \ word below. Will search through all text files
  195. : (setup)  { \ gcurs dirid -- }
  196.     watchcurs
  197.     curs -> gcurs -curs    \ Preserve cursor status
  198.     clear: Names clear: inlines clear: debugstr
  199.     unlock: inlines unlock: debugstr unlock: buf
  200.     new: loadFile
  201.     limit: path  0
  202.     DO    path IF i at: path name: fFcb i at: path swap drop ELSE clear: fFcb true THEN
  203.         IF Filecount 1+ 1
  204.             DO    i getidxfile
  205.                 IF        pad count name: topFile
  206.                         getdirid: ffcb setdirid: topfile
  207.                         openReadOnly: topFile ?error 132
  208.                         GetFileInfo: topFile  drop
  209.                         GetType: topFile txType =
  210.                         IF
  211.                             uhuh
  212.                         THEN
  213.                         close: topFile drop
  214.                 THEN
  215.             LOOP
  216.         THEN
  217.     LOOP
  218.     gcurs -> curs    \ Restore cursor status
  219.     remove: loadFile
  220.     arrowcurs ;
  221.  
  222. : cl clear: path
  223. " :::universal interfaces:" add: path ;
  224.  
  225. cl
  226.  
  227. : saveNames new: loadfile
  228.     " trapHash" name: topfile
  229.         create: topfile drop
  230.         size: names sp@ 4 write: topfile abort" 1 write error" drop
  231.         names length: names write: topfile drop
  232.         'type BIN savesig set: topfile
  233.         close: topfile drop
  234.     " InLines" name: topfile 
  235.         create: topfile drop
  236.         limit: inlines sp@ 4 write: topfile 2drop
  237.         lock: inlines get: inlines write: topfile abort" 2 write error"
  238.         'type BIN savesig set: topfile
  239.     remove: loadfile ;
  240.  
  241. \ debugging
  242.  
  243. \ : jj     
  244. \     clear: inlines clear: names clear: debugstr
  245. \     size: buf
  246. \     IF start: buf lock: buf
  247. \         BEGIN findFunction dup IF ." fn=" print: trapname size: buildStr . ELSE ." noFun=" size: buildStr . THEN
  248. \         WHILE findInLine IF ."  preParm=" size: buildStr . MakeTool ELSE ."   noparm" size: buildStr . THEN cr
  249. \         REPEAT
  250. \         start: buf
  251. \         BEGIN findProcedure
  252. \         WHILE findInLine IF MakeTool THEN
  253. \         REPEAT
  254. \     THEN ;
  255.  
  256. \ : uu    start: buf clear: inlines clear: names clear: debugstr ;
  257. \ : yy     findFunction IF 1 . findinline IF 2 . maketool THEN THEN print: trapname ;
  258.